home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl5 / LWP / Protocol / GHTTP.pm < prev    next >
Encoding:
Perl POD Document  |  2008-04-11  |  1.7 KB  |  74 lines
  1. package LWP::Protocol::GHTTP;
  2.  
  3. # You can tell LWP to use this module for 'http' requests by running
  4. # code like this before you make requests:
  5. #
  6. #    require LWP::Protocol::GHTTP;
  7. #    LWP::Protocol::implementor('http', 'LWP::Protocol::GHTTP');
  8. #
  9.  
  10. use strict;
  11. use vars qw(@ISA);
  12.  
  13. require LWP::Protocol;
  14. @ISA=qw(LWP::Protocol);
  15.  
  16. require HTTP::Response;
  17. require HTTP::Status;
  18.  
  19. use HTTP::GHTTP qw(METHOD_GET METHOD_HEAD METHOD_POST);
  20.  
  21. my %METHOD =
  22. (
  23.  GET  => METHOD_GET,
  24.  HEAD => METHOD_HEAD,
  25.  POST => METHOD_POST,
  26. );
  27.  
  28. sub request
  29. {
  30.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  31.  
  32.     my $method = $request->method;
  33.     unless (exists $METHOD{$method}) {
  34.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  35.                    "Bad method '$method'");
  36.     }
  37.  
  38.     my $r = HTTP::GHTTP->new($request->uri);
  39.  
  40.     # XXX what headers for repeated headers here?
  41.     $request->headers->scan(sub { $r->set_header(@_)});
  42.  
  43.     $r->set_type($METHOD{$method});
  44.  
  45.     # XXX should also deal with subroutine content.
  46.     my $cref = $request->content_ref;
  47.     $r->set_body($$cref) if length($$cref);
  48.  
  49.     # XXX is this right
  50.     $r->set_proxy($proxy->as_string) if $proxy;
  51.  
  52.     $r->process_request;
  53.  
  54.     my $response = HTTP::Response->new($r->get_status);
  55.  
  56.     # XXX How can get the headers out of $r??  This way is too stupid.
  57.     my @headers;
  58.     eval {
  59.     # Wrapped in eval because this method is not always available
  60.     @headers = $r->get_headers;
  61.     };
  62.     @headers = qw(Date Connection Server Content-type
  63.                   Accept-Ranges Server
  64.                   Content-Length Last-Modified ETag) if $@;
  65.     for (@headers) {
  66.     my $v = $r->get_header($_);
  67.     $response->header($_ => $v) if defined $v;
  68.     }
  69.  
  70.     return $self->collect_once($arg, $response, $r->get_body);
  71. }
  72.  
  73. 1;
  74.